home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
arith.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
40KB
|
1,524 lines
/* ******************************************************************** */
/* arith.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* arithmetic */
/* ******************************************************************** */
/*
* $Id: arith.c,v 1.5 1992/01/09 19:10:38 pab Exp $
*
* $Log: arith.c,v $
* Revision 1.5 1992/01/09 19:10:38 pab
* Fixed for low tagged ints
*
* Revision 1.4 1991/12/22 15:13:47 pab
* Xmas revision
*
* Revision 1.3 1991/09/22 19:14:32 pab
* Fixed obvious bugs
*
* Revision 1.2 1991/09/11 11:59:29 pab
* 11/9/91 First Alpha release of modified system
*
* Revision 1.1 1991/08/12 16:49:24 pab
* Initial revision
*
* Revision 1.19 1991/03/05 19:49:29 pab
* added sqrt function
*
* Revision 1.18 1991/02/13 18:15:15 kjp
* Somethign good + RCS log headers.
*
*/
/*
* Change Log:
* Version 1, May 1989
*/
#include "defs.h"
#include "structs.h"
#include "error.h"
#include "funcalls.h"
#include "global.h"
#include <math.h>
extern int abs(int);
#include "ngenerics.h"
#include "modboot.h"
EUFUN_1( Fn_numberp, a)
{
return (typeof(a)>=TYPE_INT && typeof(a)<=TYPE_LASTNUMBER ? lisptrue : nil);
}
EUFUN_CLOSE
LispObject lift_number(LispObject *stackbase, int newtype)
{
LispObject a = ARG_0(stackbase);
switch(typeof(a))
{
case TYPE_INT:
switch (newtype)
{
case TYPE_RATIONAL:
{ LispObject one = allocate_integer(stackbase+1, 1);
a = allocate_ratio(stackbase+1, ARG_0(stackbase),one);
return a;
}
case TYPE_FLOAT:
return allocate_float(stackbase+1,(double) (intval(a)));
case TYPE_COMPLEX:
{ LispObject zero = allocate_integer(stackbase+1, 0);
a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
return a;
}
default:
CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
}
case TYPE_RATIONAL:
switch (newtype) {
case TYPE_FLOAT:
CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
case TYPE_COMPLEX:
{ LispObject zero = allocate_integer(stackbase+1, 0);
a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
return a;
}
default:
CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
}
case TYPE_FLOAT:
switch (newtype) {
case TYPE_COMPLEX:
{ LispObject zero = allocate_integer(stackbase, 0);
return allocate_complex(stackbase,ARG_0(stackbase), zero);
}
case TYPE_FLOAT:
return a;
default:
CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
}
default:
CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_2(Fn_eqn, a, b)
{
if (typeof(a)>typeof(b)) {
LispObject tmp = a;
a = b;
b = tmp;
}
/* types the same is easy!! */
switch ((typeof(a)<<16)+typeof(b)) {
case (TYPE_INT<<16)+TYPE_INT:
return ((intval(a)==intval(b)) ? a : nil);
case (TYPE_INT<<16)+TYPE_RATIONAL:
case (TYPE_INT<<16)+TYPE_COMPLEX:
return nil;
case (TYPE_INT<<16)+TYPE_FLOAT:
return (((double)intval(a) == (b->FLOAT).fvalue) ? b : nil);
case (TYPE_RATIONAL<<16)+TYPE_RATIONAL:
{
LispObject ans;
EUCALLSET_2(ans, Fn_eqn, (a->RATIO).numerator,(b->RATIO).numerator);
if (ans == nil) return nil;
EUCALLSET_2(ans, Fn_eqn, (a->RATIO).denominator,(b->RATIO).denominator);
if (ans == nil) return nil;
return ARG_0(stackbase);
}
case (TYPE_RATIONAL<<16)+TYPE_FLOAT:
CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
case (TYPE_RATIONAL<<16)+TYPE_COMPLEX:
return nil;
case (TYPE_FLOAT<<16)+TYPE_FLOAT:
return ((a->FLOAT).fvalue == (b->FLOAT).fvalue ? a : nil);
case (TYPE_FLOAT<<16)+TYPE_COMPLEX:
return nil;
case (TYPE_COMPLEX<<16)+TYPE_COMPLEX:
{
LispObject ans;
EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).real,(b->COMPLEX).real);
if (ans == nil) return nil;
EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
if (ans == nil) return nil;
return ARG_0(stackbase);
}
default:
CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_2(Fn_plus, a, b)
{
if (typeof(a)>typeof(b)) {
LispObject tmp;
tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
}
if (typeof(a)!=typeof(b)) {
ARG_0(stacktop) = a;
a = lift_number(stacktop,typeof(b));
b = ARG_1(stackbase);
}
switch (typeof(a)) {
case TYPE_INT:
return allocate_integer(stacktop, intval(a) + intval(b));
case TYPE_RATIONAL:
CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
case TYPE_FLOAT:
return allocate_float(stacktop,(a->FLOAT).fvalue + (b->FLOAT).fvalue);
case TYPE_COMPLEX:
{
LispObject rr;
LispObject im;
EUCALLSET_2(rr, Fn_plus, (a->COMPLEX).real, (b->COMPLEX).real);
EUCALLSET_2(im, Fn_plus, (a->COMPLEX).imaginary, (b->COMPLEX).imaginary);
return allocate_complex(stacktop,rr,im);
}
default:
CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_2(Fn_difference, a, b)
{
if (typeof(a)!=typeof(b)) {
if (typeof(a)<typeof(b)) {
ARG_0(stacktop) = a;
ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
}
else {
ARG_0(stacktop) = b;
ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
}
}
switch (typeof(a)) {
case TYPE_INT:
return allocate_integer(stacktop, intval(a) - intval(b));
case TYPE_RATIONAL:
CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
case TYPE_FLOAT:
return allocate_float(stacktop,(a->FLOAT).fvalue - (b->FLOAT).fvalue);
case TYPE_COMPLEX:
{
LispObject rr;
LispObject im;
EUCALLSET_2(rr, Fn_difference, (a->COMPLEX).real,(b->COMPLEX).real);
EUCALLSET_2(im, Fn_difference,
(a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
return allocate_complex(stacktop,rr,im);
}
default:
CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_2(Fn_times, a, b)
{
if (typeof(a)>typeof(b)) {
LispObject tmp;
tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
}
if (typeof(a)!=typeof(b)) {
ARG_0(stacktop) = a;
ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
}
switch (typeof(a)) {
case TYPE_INT:
return allocate_integer(stacktop, intval(a) * intval(b));
case TYPE_RATIONAL:
{
LispObject num;
LispObject den;
EUCALLSET_2(num, Fn_times, (a->RATIO).numerator,(b->RATIO).numerator);
EUCALLSET_2(den, Fn_times,(a->RATIO).denominator,(b->RATIO).denominator);
return allocate_ratio(stackbase, num,den); /* Should reduce this */
}
case TYPE_FLOAT:
return allocate_float(stackbase,(a->FLOAT).fvalue * (b->FLOAT).fvalue);
case TYPE_COMPLEX:
CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
default:
CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_2(Fn_divide, a, b)
{
if (typeof(a)<typeof(b)) {
ARG_0(stacktop) = a;
ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
}
else if (typeof(a)>typeof(b)) {
ARG_0(stacktop) = b;
ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
}
/* Types are equivalent... */
switch(typeof(a)) {
case TYPE_INT:
return((LispObject) allocate_integer(stackbase, intval(a) / intval(b)));
case TYPE_RATIONAL:
{
LispObject num;
LispObject den;
EUCALLSET_2(num, Fn_times,a->RATIO.numerator,b->RATIO.denominator);
EUCALLSET_2(den, Fn_times,a->RATIO.denominator,b->RATIO.numerator);
return(allocate_ratio(stackbase,num,den)); /* Not canonical... */
}
case TYPE_FLOAT:
return(allocate_float(stackbase,a->FLOAT.fvalue / b->FLOAT.fvalue));
case TYPE_COMPLEX:
default:
CallError(stacktop,"kernel /: unimplemented facility",a,NONCONTINUABLE);
}
return(nil);
}
EUFUN_CLOSE
EUFUN_2(Fn_lessp, a, b)
{
if (typeof(a)!=typeof(b)) {
if (typeof(a)<typeof(b)) {
ARG_0(stacktop) = a;
ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
}
else {
ARG_0(stacktop) = b;
ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
}
}
switch (typeof(a)) {
case TYPE_INT:
return (intval(a) < intval(b) ? lisptrue : nil);
case TYPE_RATIONAL:
CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
case TYPE_FLOAT:
return ((a->FLOAT).fvalue < (b->FLOAT).fvalue ? lisptrue : nil);
case TYPE_COMPLEX:
CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
default:
CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_2(Fn_greaterp, a, b)
{
if (Fn_lessp(stackbase) == nil && Fn_eqn(stackbase) == nil)
return(lisptrue);
else
return(nil);
}
EUFUN_CLOSE
LispObject generic_zerop;
EUFUN_1( Gf_zerop, i)
{
return(generic_apply_1(stackbase, generic_zerop,i));
}
EUFUN_CLOSE
EUFUN_1( Fn_zerop, a)
{
switch (typeof(a)) {
case TYPE_INT:
return (intval(a) == 0 ? lisptrue : nil);
case TYPE_BIGNUM:
return nil;
case TYPE_RATIONAL:
ARG_0(stackbase) = (a->RATIO).numerator;
return Fn_zerop(stackbase);
case TYPE_FLOAT:
return ((a->FLOAT).fvalue == (double)0.0E0 ? lisptrue : nil);
case TYPE_COMPLEX:
ARG_0(stacktop) = (a->COMPLEX).real;
if (Fn_zerop(stacktop)==nil) return nil;
ARG_0(stackbase) = (a->COMPLEX).imaginary;
return Fn_zerop(stackbase);
default:
CallError(stacktop,"Unimplemented facility in zerop",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_1( Md_zerop_Number, a)
{
return Fn_zerop(stackbase);
}
EUFUN_CLOSE
LispObject generic_abs;
EUFUN_1( Gf_abs, i)
{
return(generic_apply_1(stackbase, generic_abs, i));
}
EUFUN_CLOSE
EUFUN_1( Fn_abs, a)
{
switch (typeof(a)) {
case TYPE_INT:
return (intval(a) < 0 ?
allocate_integer(stackbase, -intval(a)) : a);
case TYPE_BIGNUM:
return nil;
case TYPE_RATIONAL:
ARG_0(stacktop) = (a->RATIO).numerator;
return allocate_ratio(stackbase, Fn_abs(stacktop),(a->RATIO).denominator);
case TYPE_FLOAT:
return ((a->FLOAT).fvalue >= (double)0.0E0 ? a :
allocate_float(stackbase,-(a->FLOAT).fvalue));
case TYPE_COMPLEX:
{
LispObject r = (a->COMPLEX).real;
LispObject i = (a->COMPLEX).imaginary;
ARG_0(stacktop) = r;
ARG_1(stacktop) = r;
ARG_0(stackbase) = Fn_times(stacktop);
ARG_0(stacktop) = i;
ARG_1(stacktop) = i;
ARG_1(stackbase) = Fn_times(stacktop);
ARG_0(stackbase) = Fn_plus(stackbase);
a = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,sqrt((a->FLOAT).fvalue));
}
default:
CallError(stacktop,"Unimplemented facility in abs",a,NONCONTINUABLE);
}
return nil;
}
EUFUN_CLOSE
EUFUN_1( Md_abs_Number, a)
{
return Fn_abs(stackbase);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Integer Arithmetic */
/* *************************************************************** */
EUFUN_1( Fn_fixnump, form)
{
return (is_fixnum(form) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_oddp, form)
{
while (!is_fixnum(form))
form = CallError(stacktop,"Not an integer in oddp ",form,CONTINUABLE);
return ((intval(form)) & 1 ==0 ? nil : lisptrue);
}
EUFUN_CLOSE
EUFUN_1( Fn_evenp, form)
{
while (!is_fixnum(form))
form = CallError(stacktop,"Not an integer in evenp ",form,CONTINUABLE);
return ((intval(form)) & 1 != 0 ? nil : lisptrue);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Floating Point Arithmetic */
/* *************************************************************** */
EUFUN_1( Fn_floatp, form)
{
return (is_float(form) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_floor, form)
{
double n;
while (!is_number(form))
form = CallError(stacktop,"Not a number in floor ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
n = floor((form->FLOAT).fvalue);
if (- (double)16777216.0 < n && n < (double)16777216.0)
return allocate_integer(stackbase, (int)n);
fprintf(stderr,"Floor to a bignum missing\n");
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_ceiling, form)
{
double n;
while (!is_number(form))
form = CallError(stacktop,"Not a number in ceiling ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
n = ceil((form->FLOAT).fvalue);
if (- (double)16777216.0 < n && n < (double)16777216.0)
return allocate_integer(stackbase, (int)n);
fprintf(stderr,"Ceiling to a bignum missing\n");
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_truncate, f)
{
if (is_fixnum(f)) return(f);
if (is_float(f)) {
long down;
down = (long) floor(f->FLOAT.fvalue);
if ((double) abs((int) down) > f->FLOAT.fvalue) down += 1;
return (LispObject) allocate_integer(stackbase, (int) down);
}
CallError(stacktop,"truncate: no way",f,NONCONTINUABLE);
return(nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_round, f)
{
if (is_fixnum(f)) return(f);
if (is_float(f)) {
long down;
down = (long) floor(f->FLOAT.fvalue + (double) 0.5);
return (LispObject) allocate_integer(stackbase, (int) down);
}
CallError(stacktop,"round: no way",f,NONCONTINUABLE);
return(nil);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Floating Point Arithmetic */
/* *************************************************************** */
EUFUN_1( Fn_cos, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in cos ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,cos((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_sin, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,sin((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_sqrt, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,sqrt((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_exp, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in exp ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,exp((form->FLOAT).fvalue));
}
EUFUN_CLOSE
/* This function does not check correctly */
EUFUN_1( Fn_log, form)
{
LispObject base, arg1;
while (!is_cons(form))
form = CallError(stacktop,"No argument(s) to log ",form,CONTINUABLE);
arg1 = CAR(form);
while (!is_number(arg1))
ARG_0(stacktop) = CallError(stacktop,"Not a number in log ",arg1,CONTINUABLE);
arg1 = lift_number(stacktop, TYPE_FLOAT);
if (is_cons(CDR(form))) {
base = CAR(CDR(form));
while (!is_number(base))
base = CallError(stacktop,"Not a base in log ",base,CONTINUABLE);
ARG_0(stacktop) = arg1;
ARG_1(stacktop) = arg1;
base = lift_number(stacktop+1, TYPE_FLOAT);
return
allocate_float(stackbase,
log((arg1->FLOAT).fvalue) / log((base->FLOAT).fvalue));
}
else
return allocate_float(stackbase,log((arg1->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_acos, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in acos ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,acos((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_asin, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in asin ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stacktop,asin((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_atan, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in atan ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stacktop,atan((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_2( Fn_atan2, form1, form2)
{
while (!is_number(form1))
form1 = CallError(stacktop,"Not a number in atan2 ",form1,CONTINUABLE);
ARG_0(stacktop) = form1;
ARG_0(stackbase) = lift_number(stacktop, TYPE_FLOAT);
while (!is_number(form2))
form2 = CallError(stacktop,"Not a number in atan2 ",form2,CONTINUABLE);
form2 = lift_number(stackbase+1, TYPE_FLOAT);
form1 = ARG_0(stackbase);
return allocate_float(stacktop,
atan2((form1->FLOAT).fvalue,(form2->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_tan, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in tan ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stacktop,tan((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_acosh, form)
{
double x;
while (!is_number(form))
form = CallError(stacktop,"Not a number in acosh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
x = (form->FLOAT).fvalue;
return allocate_float(stackbase,log(x+sqrt(x*x-1)));
}
EUFUN_CLOSE
EUFUN_1( Fn_asinh, form)
{
double x;
while (!is_number(form))
form = CallError(stacktop,"Not a number in asinh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
x = (form->FLOAT).fvalue;
return allocate_float(stackbase,log(x+sqrt(x*x+1)));
}
EUFUN_CLOSE
EUFUN_1( Fn_atanh, form)
{
double x;
while (!is_number(form))
form = CallError(stacktop,"Not a number in atanh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
x = (form->FLOAT).fvalue;
return allocate_float(stackbase,0.5*(log((x+1.0)/(x-1.0))));
}
EUFUN_CLOSE
EUFUN_1( Fn_cosh, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in cosh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,cosh((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_sinh, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in sinh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,sinh((form->FLOAT).fvalue));
}
EUFUN_CLOSE
EUFUN_1( Fn_tanh, form)
{
while (!is_number(form))
form = CallError(stacktop,"Not a number in tanh ",form,CONTINUABLE);
form = lift_number(stackbase, TYPE_FLOAT);
return allocate_float(stackbase,tanh((form->FLOAT).fvalue));
}
EUFUN_CLOSE
/* Generic versions... */
LispObject generic_eqn;
EUFUN_2(Gf_eqn, i1, i2)
{
return(generic_apply_2(stackbase, generic_eqn, i1, i2));
}
EUFUN_CLOSE
EUFUN_2(Md_eqn_Number_Number, i1, i2)
{
return(Fn_eqn(stackbase));
}
EUFUN_CLOSE
LispObject generic_binary_plus;
EUFUN_2(Gf_binary_plus, a, b)
{
return(generic_apply_2(stackbase, generic_binary_plus, a, b));
}
EUFUN_CLOSE
EUFUN_2(Md_binary_plus_Object_Object, n1, n2)
{
return(Fn_plus(stackbase));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_plus_Integer_Integer, i1, i2)
{
return((LispObject)allocate_integer(stackbase, intval(i1)+intval(i2)));
}
EUFUN_CLOSE
LispObject generic_binary_difference;
EUFUN_2( Gf_binary_difference, a, b)
{
return(generic_apply_2(stackbase, generic_binary_difference,a, b));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_difference_Object_Object, n1, n2)
{
return(Fn_difference(stackbase));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_difference_Integer_Integer, i1, i2)
{
return((LispObject)allocate_integer(stackbase, intval(i1)-intval(i2)));
}
EUFUN_CLOSE
LispObject generic_binary_times;
EUFUN_2( Gf_binary_times, a, b)
{
return(generic_apply_2(stackbase, generic_binary_times, a, b));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_times_Object_Object, n1, n2)
{
return(Fn_times(stackbase));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_times_Integer_Integer, i1, i2)
{
return((LispObject)allocate_integer(stackbase, intval(i1)*intval(i2)));
}
EUFUN_CLOSE
LispObject generic_binary_divide;
EUFUN_2( Gf_binary_divide, a, b)
{
return(generic_apply_2(stackbase, generic_binary_divide, a, b));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_divide_Object_Object, n1, n2)
{
return(Fn_divide(stackbase));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_divide_Integer_Integer, i1, i2)
{
return((LispObject) allocate_integer(stacktop, intval(i1)/intval(i2)));
}
EUFUN_CLOSE
/* Wrappers... */
EUFUN_1( Fn_nary_plus, args)
{
LispObject walker;
LispObject n1,n2;
walker = args;
if (!is_cons(walker))
CallError(stacktop,"+: no arguments",args,NONCONTINUABLE);
n1 = CAR(walker); walker = CDR(walker);
if (!is_cons(walker))
CallError(stacktop,"+: insufficient arguments",args,NONCONTINUABLE);
n2 = CAR(walker); walker = CDR(walker);
n1 = generic_apply_2(stacktop, generic_binary_plus, n1, n2);
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_plus, n1, CAR(walker));
UNSTACK_TMP(walker);
}
return(n1);
}
EUFUN_CLOSE
EUFUN_1( Fn_nary_difference, args)
{
LispObject walker;
LispObject n1,n2;
walker = args;
if (!is_cons(walker))
CallError(stacktop,"-: no arguments",args,NONCONTINUABLE);
n1 = CAR(walker); walker = CDR(walker);
if (!is_cons(walker)) {
LispObject xx;
STACK_TMP(n1);
xx = allocate_integer(stacktop, 0);
UNSTACK_TMP(n1);
return(generic_apply_2(stackbase, generic_binary_difference,xx, n1));
}
n2 = CAR(walker); STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_difference,n1, n2);
UNSTACK_TMP(walker);
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_difference,n1, CAR(walker));
UNSTACK_TMP(walker);
}
return(n1);
}
EUFUN_CLOSE
EUFUN_1( Fn_nary_times, args)
{
LispObject walker;
LispObject n1,n2;
walker = args;
if (!is_cons(walker))
CallError(stacktop,"*: no arguments",args,NONCONTINUABLE);
n1 = CAR(walker); walker = CDR(walker);
if (!is_cons(walker))
CallError(stacktop,"*: insufficient arguments",args,NONCONTINUABLE);
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_times, n1, CAR(walker));
UNSTACK_TMP(walker);
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_times,n1, CAR(walker));
UNSTACK_TMP(walker);
}
return(n1);
}
EUFUN_CLOSE
EUFUN_1( Fn_nary_divide, args)
{
LispObject walker;
LispObject n1,n2;
walker = args;
if (!is_cons(walker))
CallError(stacktop,"/: no arguments",args,NONCONTINUABLE);
n1 = CAR(walker); walker = CDR(walker);
if (!is_cons(walker))
CallError(stacktop,"/: insufficient arguments",args,NONCONTINUABLE);
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_divide, n1, CAR(walker));
UNSTACK_TMP(walker);
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
n1 = generic_apply_2(stacktop, generic_binary_divide,n1, CAR(walker));
UNSTACK_TMP(walker);
}
return(n1);
}
EUFUN_CLOSE
/*
* Integer operations...
*/
EUFUN_2(Fn_quotient, n, m)
{
if (!is_fixnum(n))
CallError(stacktop,"quotient: not an integer",n,NONCONTINUABLE);
if (!is_fixnum(m))
CallError(stacktop,"quotient: not an integer",m,NONCONTINUABLE);
return((LispObject) allocate_integer(stackbase, intval(n)/intval(m)));
}
EUFUN_CLOSE
EUFUN_2(Fn_remainder, n, m)
{
if (!is_fixnum(n))
CallError(stacktop,"remainder(hack): non-integer as argument",n,NONCONTINUABLE);
if (!is_fixnum(m))
CallError(stacktop,"remainder(hack): non-integer as argument",m,NONCONTINUABLE);
return((LispObject) allocate_integer(stackbase, intval(n)%intval(m)));
}
EUFUN_CLOSE
/*
* GCD calculation.
*/
LispObject generic_binary_gcd;
EUFUN_2(Gf_binary_gcd, n1, n2)
{
return(generic_apply_2(stackbase, generic_binary_gcd,n1, n2));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_gcd_Integer_Integer, n1, n2)
{
extern int abs(int);
int a,b,r;
LispObject ans;
a = abs(intval(n1)); b = abs(intval(n2));
do {
r = a%b;
a = b; b = r;
} while(b != 0);
return (LispObject) allocate_integer(stackbase, a);
return(ans);
}
EUFUN_CLOSE
EUFUN_1( Fn_gcd, args)
{
LispObject v1,v2;
if (intval(Fn_length(stackbase)) < 2)
CallError(stacktop,"gcd: insufficient arguments",args,NONCONTINUABLE);
v1 = CAR(args); args = CDR(args);
while (is_cons(args)) {
ARG_0(stacktop) = v1;
ARG_1(stacktop)= v2 = CAR(args); ARG_0(stackbase) = CDR(args);
v1 = Gf_binary_gcd(stacktop);
args = ARG_0(stackbase);
}
return(v1);
}
EUFUN_CLOSE
/*
* LCM calculation.
*/
LispObject generic_binary_lcm;
EUFUN_2(Gf_binary_lcm, n1, n2)
{
return(generic_apply_2(stackbase, generic_binary_lcm, n1, n2));
}
EUFUN_CLOSE
EUFUN_2( Md_binary_lcm_Integer_Integer, n1, n2)
{
extern int abs(int);
int a,b,r,origa,origb;
a = abs(intval(n1)); b = abs(intval(n2));
origa = a; origb = b;
do {
r = a%b;
a = b; b = r;
} while(b != 0);
a = (origa/a)*origb;
return (LispObject) allocate_integer(stackbase, a);
}
EUFUN_CLOSE
EUFUN_1( Fn_lcm, args)
{
LispObject v1,v2;
if (intval(Fn_length(stackbase)) < 2)
CallError(stacktop,"lcm: insufficient arguments",args,NONCONTINUABLE);
v1 = CAR(args); args = CDR(args);
while (is_cons(args)) {
ARG_0(stacktop) = v1;
ARG_1(stacktop) = v2 = CAR(args); ARG_0(stackbase) = CDR(args);
v1 = Gf_binary_lcm(stacktop);
args = ARG_0(stackbase);
}
return(v1);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Ordering */
/* *************************************************************** */
LispObject generic_binary_lt;
EUFUN_2(Gf_binary_lt, a, b)
{
return(generic_apply_2(stackbase, generic_binary_lt, a, b));
}
EUFUN_CLOSE
EUFUN_2(Md_binary_lt_Number, a, b)
{
return(Fn_lessp(stackbase));
}
EUFUN_CLOSE
EUFUN_2(Md_binary_lt_Integer, a, b)
{
return(intval(a)<intval(b) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_lt, args)
{
LispObject a;
if (!is_cons(args))
CallError(stacktop,"<: insufficient arguments",args,NONCONTINUABLE);
a = CAR(args); args = CDR(args);
if (!is_cons(args)) return(lisptrue);
while (is_cons(args)) {
ARG_0(stacktop) = a;
ARG_1(stacktop) = CAR(args);
if (Gf_binary_lt(stacktop) == nil) return(nil);
a = CAR(args);
args = CDR(args);
ARG_0(stackbase) = args;
}
return(lisptrue);
}
EUFUN_CLOSE
LispObject generic_binary_gt;
EUFUN_2(Gf_binary_gt, a, b)
{
return(generic_apply_2(stackbase, generic_binary_gt,a, b));
}
EUFUN_CLOSE
EUFUN_2(Md_binary_gt_Number, a, b)
{
ARG_0(stackbase) = b;
ARG_1(stackbase) = a;
return(Gf_binary_lt(stackbase));
}
EUFUN_CLOSE
EUFUN_2(Md_binary_gt_Integer, a, b)
{
return(intval(a)>intval(b) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_gt, args)
{
LispObject a;
if (!is_cons(args))
CallError(stacktop,">: insufficient arguments",args,NONCONTINUABLE);
a = CAR(args); args = CDR(args);
if (!is_cons(args)) return(lisptrue);
while (is_cons(args)) {
ARG_0(stacktop) = a;
ARG_1(stacktop) = CAR(args);
if (Gf_binary_gt(stacktop) == nil) return(nil);
a = CAR(args);
args = CDR(args);
ARG_0(stackbase) = args;
}
#ifdef jpff_version /* Fri Sep 6 17:51:33 1991 */
/**/ while (is_cons(args)) {
/**/ ARG_0(stacktop) = a;
/**/ ARG_1(stacktop) = CAR(args);
/**/ ARG_0(stackbase) = CDR(args);
/**/ if (Gf_binary_gt(stacktop) == nil) return(nil);
/**/ a = ARG_1(stacktop);
/**/ args = ARG_0(stackbase);
/**/ }
#endif /* jpff's version Fri Sep 6 17:51:33 1991 */
return(lisptrue);
}
EUFUN_CLOSE
EUFUN_1( Fn_lt_or_equal, args)
{
LispObject a;
if (!is_cons(args))
CallError(stacktop,"<=: insufficient arguments",args,NONCONTINUABLE);
a = CAR(args); args = CDR(args);
STACK_TMP(args);
if (!is_cons(args)) return(lisptrue);
while (is_cons(args)) {
ARG_0(stacktop) = a;
ARG_1(stacktop) = CAR(args);
if (Gf_binary_lt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
return nil;
a = CAR(args);
args = CDR(args);
ARG_0(stackbase) = args;
}
return(lisptrue);
}
EUFUN_CLOSE
EUFUN_1( Fn_gt_or_equal, args)
{
LispObject a;
if (!is_cons(args))
CallError(stacktop,">=: insufficient arguments",args,NONCONTINUABLE);
a = CAR(args); args = CDR(args);
ARG_0(stackbase)=args;
if (!is_cons(args)) return(lisptrue);
while (is_cons(args)) {
ARG_0(stacktop) = a;
ARG_1(stacktop) = CAR(args);
if (Gf_binary_gt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
return nil;
a = CAR(args);
args = CDR(args);
ARG_0(stackbase) = args;
}
return(lisptrue);
}
EUFUN_CLOSE
LispObject generic_max;
EUFUN_2(Gf_max, a, b)
{
return(generic_apply_2(stackbase, generic_max, a, b));
}
EUFUN_CLOSE
EUFUN_2(Md_max_Number_Number, a, b)
{
if (EUCALL_2(Gf_binary_lt, a,b) != nil) return(ARG_1(stackbase));
return(ARG_0(stackbase));
}
EUFUN_CLOSE
EUFUN_1( Fn_min, a)
{
LispObject ans,xxx;
while (!is_cons(a))
a = CallError(stacktop,"Too few arguments for min ",a,CONTINUABLE);
ans = CAR(a);
a = CDR(a);
while (!is_number(ans))
ans = CallError(stacktop,"Non numeric argument for min ",ans,CONTINUABLE);
while (a != nil) {
LispObject b = CAR(a);
while (!is_number(b))
b = CallError(stacktop,"Non numeric argument for min ",b,CONTINUABLE);
ARG_0(stackbase) = a;
STACK_TMP(ans);
STACK_TMP(b);
ARG_0(stacktop) = ans;
ARG_1(stacktop) = b;
xxx = Md_max_Number_Number(stacktop);
UNSTACK_TMP(b);
UNSTACK_TMP(ans);
if (xxx == ans)
ans = b;
else /*ans = ans */;
a = CDR(ARG_0(stackbase));
}
return(ans);
}
EUFUN_CLOSE
EUFUN_1( Fn_max, a)
{
LispObject ans,xxx;
while (!is_cons(a))
a = CallError(stacktop,"Too few arguments for max ",a,CONTINUABLE);
ans = CAR(a);
a = CDR(a);
while (!is_number(ans))
ans = CallError(stacktop,"Non numeric argument for max ",ans,CONTINUABLE);
while (a != nil) {
LispObject b = CAR(a);
while (!is_number(b))
b = CallError(stacktop,"Non numeric argument for max ",b,CONTINUABLE);
ARG_0(stackbase) = a;
STACK_TMP(ans);
STACK_TMP(b);
ARG_0(stacktop) = ans;
ARG_1(stacktop) = b;
xxx = Md_max_Number_Number(stacktop);
UNSTACK_TMP(b);
UNSTACK_TMP(ans);
if (xxx == b)
ans = b;
else /* ans = ans */;
a = CDR(ARG_0(stackbase));
}
return(ans);
}
EUFUN_CLOSE
/* *************************************************************** */
/* COMPLEX NUMBERS */
/* *************************************************************** */
EUFUN_2( Fn_Make_Rectangular, x, y)
{
while (!is_number(x) || (typeof(x)== TYPE_COMPLEX))
x = CallError(stacktop,"make-rectangular: first argument not valid number",
x,CONTINUABLE);
while (!is_number(y) || (typeof(y)==TYPE_COMPLEX))
y = CallError(stacktop,"make-rectangular: second argument not valid number",
y,CONTINUABLE);
return allocate_complex(stackbase,x,y);
}
EUFUN_CLOSE
EUFUN_1( Fn_Real_Part, obj)
{
while (!is_number(obj))
obj = CallError(stacktop,"Not a number in real-part",obj,CONTINUABLE);
if (typeof(obj)==TYPE_COMPLEX)
return obj->COMPLEX.real;
else return obj;
}
EUFUN_CLOSE
EUFUN_1( Fn_Imaginary_Part, obj)
{
while (!is_number(obj))
obj = CallError(stacktop,"Not a number in imaginary-part",obj,CONTINUABLE);
if (typeof(obj)==TYPE_COMPLEX)
return obj->COMPLEX.imaginary;
else return allocate_float(stackbase,(double)0.0);
}
EUFUN_CLOSE
/* *************************************************************** */
/* RATIONAL NUMBERS */
/* *************************************************************** */
EUFUN_1( Fn_Numerator, obj)
{
while (!is_number(obj))
obj = CallError(stacktop,"Not a number in numerator",obj,CONTINUABLE);
if (typeof(obj)==TYPE_RATIONAL)
return obj->RATIO.numerator;
else return obj;
}
EUFUN_CLOSE
EUFUN_1( Fn_Denominator, obj)
{
while (!is_number(obj))
obj = CallError(stacktop,"Not a number in denominator",obj,CONTINUABLE);
if (typeof(obj)==TYPE_RATIONAL)
return obj->RATIO.denominator;
else return allocate_integer(stackbase, 1);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Initialisation of this section */
/* *************************************************************** */
#define ARITH_ENTRIES 75
MODULE Module_arith;
LispObject Module_arith_values[ARITH_ENTRIES];
void initialise_arith(LispObject *stacktop)
{
extern LispObject generic_equal;
open_module(stacktop,
&Module_arith,
Module_arith_values,
"arith",
ARITH_ENTRIES);
(void) make_module_function(stacktop,"numberp",Fn_numberp,1);
generic_binary_plus
= make_wrapped_module_generic(stacktop,"binary-plus",2,Gf_binary_plus);
add_root(&generic_binary_plus);
(void) make_module_function(stacktop,"generic_binary_plus,Number,Number",
Md_binary_plus_Object_Object,2
);
#ifndef WITH_BIGNUMS
(void) make_module_function(stacktop,"generic_binary_plus,Integer,Integer",
Md_binary_plus_Integer_Integer,2
);
#endif
(void) make_module_function(stacktop,"+",Fn_nary_plus,-1);
generic_binary_difference
= make_wrapped_module_generic(stacktop,"binary-difference",2,Gf_binary_difference);
add_root(&generic_binary_difference);
(void) make_module_function(stacktop,"generic_binary_difference,Number,Number",
Md_binary_difference_Object_Object,2
);
#ifndef WITH_BIGNUMS
(void) make_module_function(stacktop,"generic_binary_difference,Integer,Integer",
Md_binary_difference_Integer_Integer,2
);
#endif
(void) make_module_function(stacktop,"-",Fn_nary_difference,-1);
generic_binary_times
= make_wrapped_module_generic(stacktop,"binary-times",2,Gf_binary_times);
add_root(&generic_binary_times);
(void) make_module_function(stacktop,"generic_binary_times,Number,Number",
Md_binary_times_Object_Object,2
);
#ifndef WITH_BIGNUMS
(void) make_module_function(stacktop,"generic_binary_times,Integer,Integer",
Md_binary_times_Integer_Integer,2
);
#endif
(void) make_module_function(stacktop,"*",Fn_nary_times,-1);
generic_binary_divide
= make_wrapped_module_generic(stacktop,"binary-divide",2,Gf_binary_divide);
add_root(&generic_binary_divide);
(void) make_module_function(stacktop,"generic_binary_divide,Number,Number",
Md_binary_divide_Object_Object,2
);
/*
(void) make_module_function(stacktop,generic_binary_divide,
Md_binary_divide_Integer_Integer,
Integer,Integer);
*/
(void) make_module_function(stacktop,"/",Fn_nary_divide,-1);
generic_binary_gcd
= make_wrapped_module_generic(stacktop,"binary-gcd",2,Gf_binary_gcd);
add_root(&generic_binary_gcd);
(void) make_module_function(stacktop,"generic_binary_gcd,Integer,Integer",
Md_binary_gcd_Integer_Integer,2
);
(void) make_module_function(stacktop,"gcd",Fn_gcd,-1);
generic_binary_lcm
= make_wrapped_module_generic(stacktop,"binary-lcm",2,Gf_binary_lcm);
add_root(&generic_binary_lcm);
(void) make_module_function(stacktop,"generic_binary_lcm,Integer,Integer",
Md_binary_lcm_Integer_Integer,2
);
(void) make_module_function(stacktop,"lcm",Fn_lcm,-1);
generic_eqn = make_wrapped_module_generic(stacktop,"=",2,Gf_eqn);
add_root(&generic_eqn);
(void) make_module_function(stacktop,"generic_eqn,Number,Number",
Md_eqn_Number_Number,2
);
(void) make_module_function(stacktop,"generic_equal,Number,Number",
Gf_eqn,2
);
generic_zerop = make_wrapped_module_generic(stacktop,"zerop",1,Gf_zerop);
add_root(&generic_zerop);
(void) make_module_function(stacktop,"generic_zerop,Number", Md_zerop_Number,1);
generic_abs = make_wrapped_module_generic(stacktop,"abs",1,Gf_abs);
add_root(&generic_abs);
(void) make_module_function(stacktop,"generic_abs,Number",Md_abs_Number,1);
/* Maths constants... */
(void) make_module_entry(stacktop, "pi",allocate_float(stacktop,(double) 3.141592653589794));
(void) make_module_entry(stacktop, "e",allocate_float(stacktop,(double) 2.718281828459046));
(void) make_module_function(stacktop,"single-precision-integer-p",Fn_fixnump,1);
(void) make_module_function(stacktop,"oddp",Fn_oddp,1);
(void) make_module_function(stacktop,"evenp",Fn_evenp,1);
(void) make_module_function(stacktop,"floatp",Fn_floatp,1);
(void) make_module_function(stacktop,"floor",Fn_floor,1);
(void) make_module_function(stacktop,"ceiling",Fn_ceiling,1);
(void) make_module_function(stacktop,"sin",Fn_sin,1);
(void) make_module_function(stacktop,"cos",Fn_cos,1);
(void) make_module_function(stacktop,"exp",Fn_exp,1);
(void) make_module_function(stacktop,"acos",Fn_acos,1);
(void) make_module_function(stacktop,"asin",Fn_asin,1);
(void) make_module_function(stacktop,"atan",Fn_atan,1);
(void) make_module_function(stacktop,"atan2",Fn_atan2,2);
(void) make_module_function(stacktop,"tan",Fn_tan,1);
(void) make_module_function(stacktop,"acosh",Fn_acosh,1);
(void) make_module_function(stacktop,"asinh",Fn_asinh,1);
(void) make_module_function(stacktop,"atanh",Fn_atanh,1);
(void) make_module_function(stacktop,"cosh",Fn_cosh,1);
(void) make_module_function(stacktop,"sinh",Fn_sinh,1);
(void) make_module_function(stacktop,"tanh",Fn_tanh,1);
(void) make_module_function(stacktop,"log",Fn_log,-1);
(void) make_module_function(stacktop,"quotient",Fn_quotient,2);
(void) make_module_function(stacktop,"remainder",Fn_remainder,2);
(void) make_module_function(stacktop,"modulo",Fn_remainder,2);
generic_binary_lt
= make_wrapped_module_generic(stacktop,"binary-lt",2,Gf_binary_lt);
add_root(&generic_binary_lt);
(void) make_module_function(stacktop,"generic_binary_lt,Number,Number",
Md_binary_lt_Number,2
);
(void) make_module_function(stacktop,"generic_binary_lt,Integer,Integer",
Md_binary_lt_Integer,2
);
(void) make_module_function(stacktop,"<",Fn_lt,-1);
generic_binary_gt
= make_wrapped_module_generic(stacktop,"binary-gt",2,Gf_binary_gt);
add_root(&generic_binary_gt);
(void) make_module_function(stacktop,"generic_binary_gt,Number,Number",
Md_binary_gt_Number,2
);
(void) make_module_function(stacktop,"generic_binary_gt,Integer,Integer",
Md_binary_gt_Integer,2
);
(void) make_module_function(stacktop,">",Fn_gt,-1);
(void) make_module_function(stacktop,"<=",Fn_lt_or_equal,-1);
(void) make_module_function(stacktop,">=",Fn_gt_or_equal,-1);
(void) make_module_function(stacktop,"max",Fn_max,-1);
(void) make_module_function(stacktop,"min",Fn_min,-1);
(void) make_module_function(stacktop,"truncate",Fn_truncate,1);
(void) make_module_function(stacktop,"round",Fn_round,1);
(void) make_module_function(stacktop,"real-part",Fn_Real_Part,1);
(void) make_module_function(stacktop,"imaginary-part",Fn_Imaginary_Part,1);
(void) make_module_function(stacktop,"make-rectangular",Fn_Make_Rectangular,2);
(void) make_module_function(stacktop,"numerator",Fn_Numerator,1);
(void) make_module_function(stacktop,"denominator",Fn_Denominator,1);
/* PAB added */
(void) make_module_function(stacktop,"sqrt",Fn_sqrt,1);
close_module();
}